(library (model entity)
  (export Entity
          make-entity
          entity-ordered-key-value-pairs
          serialize-entity
          ;; knowledge about ids
          TEMPLATE-ID
          RANDOM-CHAR-IDS
          STAGE-CHAR-IDS
          BOSS-CHAR-IDS
          ITEM-IDS
          CRIMINAL-ID
          RANDOM-HUNTER-BANDIT-ID
          RANDOM-CHAR-ID
          ENTITY-IDS
          ;; validation
          validate-entity-attributes
          ;; data abstraction
          get:entity/attrs
          get:entity-attr/value
          get:entity-attr/name
          get:entity/id
          get:entity/hp
          get:entity/x
          get:entity/y
          get:entity/act
          get:entity/ratio
          get:entity/times
          get:entity/reserve
          get:entity/join
          get:entity/join-reserve
          get:entity/boss
          get:entity/soldier
          get:entity/comment
          ;; conversion
          entity-list-repr->entity)
  (import (rnrs base)
          (only (guile)
                lambda* λ
                ;; input output
                simple-format
                call-with-output-string
                ;; string operations
                string-trim-right)
          (ice-9 exceptions)
          ;; (srfi srfi-9)
          (srfi srfi-9 gnu)
          (srfi srfi-1)
          (prefix (logging) log:)
          ;; custom libs
          (lib alist-utils)
          (lib string-utils)
          (peg-tree-utils)))


(define-immutable-record-type Entity
  ;; define constructor
  (construct-entity id
                    x y
                    hp
                    act
                    ratio times reserve
                    join
                    join-reserve
                    boss soldier
                    comment)
  ;; define predicate
  entity?
  ;; define accessors and functional setters
  (id entity-id set-entity-id)
  (x entity-x set-entity-x)
  (y entity-y set-entity-y)
  (hp entity-hp set-entity-hp)
  (act entity-act set-entity-act)
  (ratio entity-ratio set-entity-ratio)
  (times entity-times set-entity-times)
  (reserve entity-reserve set-entity-reserve)
  (join entity-join set-entity-join)
  (join-reserve entity-join-reserve set-entity-join-reserve)
  (boss entity-boss set-entity-boss)
  (soldier entity-soldier set-entity-soldier)
  (comment entity-comment set-entity-comment))


;; Encoding some knowledge of the game ids in the code of
;; this program. NOTE: At a later point in time, it might be
;; a good idea to load these ids from some configuration
;; file, so that the generator can be extended to work with
;; non-standard LF2 versions.
(define TEMPLATE-ID 0)
(define RANDOM-CHAR-IDS
  '(1 2 #|no id 3|# 4 5 6 7 8 9 10 11))
(define STAGE-CHAR-IDS
  '(30 31 32 33 34 35 36 37 #|38 is Bat|# 39))
(define BOSS-CHAR-IDS
  '(38 50 51 52))
(define ITEM-IDS
  '(100 101 120 121 122 123 124 150 151 217 218))
(define CRIMINAL-ID 300)
(define RANDOM-HUNTER-BANDIT-ID 3000)
(define RANDOM-CHAR-ID 1000)
(define ENTITY-IDS
  `(,TEMPLATE-ID
    ,@RANDOM-CHAR-IDS
    ,@STAGE-CHAR-IDS
    ,@BOSS-CHAR-IDS
    ,@ITEM-IDS
    ,CRIMINAL-ID
    ,RANDOM-HUNTER-BANDIT-ID
    ,RANDOM-CHAR-ID))


;; Vailation at runtime has a performance cost, but I do not
;; think, that this program is a performance critical
;; application, so I value safety over speed at this point.
(define validate-entity-attributes
  (lambda* (id
            x y
            hp
            act
            ratio times reserve
            join
            join-reserve
            boss soldier
            comment
            #:key
            (limit-ids #t))
    "Check some invariants about entity attributes at runtime."
    (cond
     [(and boss soldier)
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "entity cannot be both boss and soldier")
        (make-exception-with-irritants (list boss soldier))
        (make-exception-with-origin 'validate-entity-attributes)))]
     [(not id)
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "no entity id")
        (make-exception-with-irritants (list id))
        (make-exception-with-origin 'validate-entity-attributes)))]
     [(not (member id ENTITY-IDS))
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "unrecognized entity id")
        (make-exception-with-irritants (list id))
        (make-exception-with-origin 'validate-entity-attributes)))]
     [(not (string? comment))
      (raise-exception
       (make-exception
        (make-non-continuable-error)
        (make-exception-with-message "entity comment is not a string")
        (make-exception-with-irritants (list comment))
        (make-exception-with-origin 'validate-entity-attributes)))]
     [else #t])))


(define make-entity
  (lambda* (id
            #:key
            (x #f)
            (y #f)
            (hp #f)
            (act #f)
            (ratio #f)
            (times #f)
            (reserve #f)
            (join #f)
            (join-reserve #f)
            (boss #f)
            (soldier #f)
            (comment #f))
    "Create an entity struct. Also performs validation on
the entity's attributes."
    ;; first we check for impossible attribute combinations
    (and
     (validate-entity-attributes
      id x y hp act ratio times reserve join join-reserve boss soldier comment)
     (construct-entity
      id x y hp act ratio times reserve join join-reserve boss soldier comment))))


;; DATA ABSTRACTION

;; Some function for abstracting from accessing the list
;; representation of an entity.


(define get:entity/attrs
  (λ (entity)
    (drop-tag entity)))


(define get:entity-attr/value
  (lambda* (attr #:key (convert (λ (val) val)))
    (convert (first (drop (drop-tag attr) 1)))))


(define get:entity-attr/name
  (λ (attr)
    (second (first (drop-tag attr)))))


;; ATTRIBUTES

(define get:entity/id
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [id-attr
            (alist-refs attrs
                        '(ID-ATTRIBUTE)
                        #:default-thunk
                        (λ ()
                          (raise-exception
                           (make-exception
                            (make-non-continuable-error)
                            (make-exception-with-message "entity does not have an id")
                            (make-exception-with-irritants (list entity))
                            (make-exception-with-origin 'get:entity/id)))))])
      (get:entity-attr/value id-attr #:convert string->number))))


(define get:entity/hp
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [hp-attr
            (alist-refs attrs '(HP-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and hp-attr
           (get:entity-attr/value hp-attr #:convert string->number)))))


(define get:entity/x
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [x-attr
            (alist-refs attrs '(X-COORD-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and x-attr
           (get:entity-attr/value x-attr #:convert string->number)))))


(define get:entity/y
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [y-attr
            (alist-refs attrs '(Y-COORD-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and y-attr
           (get:entity-attr/value y-attr #:convert string->number)))))


(define get:entity/act
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [act-attr
            (alist-refs attrs '(ACT-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and act-attr
           (get:entity-attr/value act-attr #:convert string->number)))))


(define get:entity/ratio
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [ratio-attr
            (alist-refs attrs '(RATIO-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and ratio-attr
           (get:entity-attr/value ratio-attr #:convert string->number)))))


(define get:entity/times
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [times-attr
            (alist-refs attrs '(TIMES-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and times-attr
           (get:entity-attr/value times-attr #:convert string->number)))))


(define get:entity/reserve
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [reserve-attr
            (alist-refs attrs '(RESERVE-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and reserve-attr
           (get:entity-attr/value reserve-attr #:convert string->number)))))


(define get:entity/join
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [join-attr
            (alist-refs attrs '(JOIN-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and join-attr
           (get:entity-attr/value join-attr #:convert string->number)))))


(define get:entity/join-reserve
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [join-reserve-attr
            (alist-refs attrs '(JOIN-RESERVE-ATTRIBUTE) #:default-thunk (λ () #f))])
      (and join-reserve-attr
           (get:entity-attr/value join-reserve-attr #:convert string->number)))))


(define get:entity/boss
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [boss-attr
            (alist-refs attrs '(BOSS-TAG) #:default-thunk (λ () #f))])
      (and boss-attr
           (get:entity-attr/value boss-attr)))))


(define get:entity/soldier
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [soldier-attr
            (alist-refs attrs '(SOLDIER-TAG) #:default-thunk (λ () #f))])
      (and soldier-attr
           (get:entity-attr/value soldier-attr)))))


(define get:entity/comment
  (λ (entity)
    (let* ([attrs (drop-tag entity)]
           [comment (alist-refs attrs '(ENTITY-COMMENT))]
           [comment-attrs (drop-tag comment)])
      (first (alist-refs comment-attrs '(ENTITY-COMMENT-TEXT))))))


(define entity-list-repr->entity
  (lambda (list-repr)
    "Convert the list representation of an entity into a
struct representation."
    ;; Example entity in list representation:
    ;; (ENTITY
    ;;  (ID-ATTRIBUTE (ID-ATTRIBUTE-NAME "id") "1000")
    ;;  (HP-ATTRIBUTE (HP-ATTRIBUTE-NAME "hp") "250")
    ;;  (RATIO-ATTRIBUTE
    ;;   (RATIO-ATTRIBUTE-NAME "ratio")
    ;;   "0.3")
    ;;  (SOLDIER-TAG "<soldier>"))
    (let ([attributes (get:entity/attrs list-repr)])
      (let ([id (get:entity/id list-repr)]
            [hp (get:entity/hp list-repr)]
            [x (get:entity/x list-repr)]
            [y (get:entity/y list-repr)]
            [act (get:entity/act list-repr)]
            [ratio (get:entity/ratio list-repr)]
            [times (get:entity/times list-repr)]
            [reserve (get:entity/reserve list-repr)]
            [join (get:entity/join list-repr)]
            [join-reserve (get:entity/join-reserve list-repr)]
            [boss (get:entity/boss list-repr)]
            [soldier (get:entity/soldier list-repr)]
            [comment (get:entity/comment list-repr)])
      (make-entity id
                   #:x x #:y y
                   #:hp hp
                   #:act act
                   #:ratio ratio
                   #:times times
                   #:reserve reserve
                   #:join join #:join-reserve reserve
                   #:boss boss #:soldier soldier
                   #:comment comment)))))


(define entity-ordered-key-value-pairs
  (λ (entity)
    "Get the attributes of the given ENTITY in the order, in
which they should appear in stage.dat."
    (list (cons "id" (entity-id entity))
          (cons "hp" (entity-hp entity))
          (cons "x" (entity-x entity))
          (cons "y" (entity-y entity))
          (cons "ratio" (entity-ratio entity))
          (cons "times" (entity-times entity))
          (cons "reserve" (entity-reserve entity))
          (cons "join" (entity-join entity))
          (cons "join-reserve" (entity-join-reserve entity))
          (cons "boss" (entity-boss entity))
          (cons "soldier" (entity-soldier entity))
          (cons "comment" (entity-comment entity)))))


(define serialize-entity
  (lambda* (entity #:key
                   (indent-level 2)
                   (indent-width 8)
                   (indent-string " ")
                   (attribute-spacing 2)
                   (name-value-spacing 1)
                   (separator " "))
    "Serialize an ENTITY to its format of stage.dat. The
default formating is that, which is found in original data
file."
    (let* ([ordered-attrs
            (filter (λ (key-val-pair) (cdr key-val-pair))
                    (entity-ordered-key-value-pairs entity))])
      ;; trim any trailing whitespace
      (string-trim-right
       (call-with-output-string
         (λ (port)
           ;; Output the indent, if there is any.
           (let* ([one-indent (string-repeat indent-string indent-width)]
                  [indent (string-repeat one-indent indent-level)])
             (simple-format port "~a" indent))

           (let iter-attrs ([attrs ordered-attrs])
             (cond
              ;; If no more attributes exist, write an empty
              ;; string to the string port and do not recur.
              [(null? attrs) (simple-format port "")]
              [else
               (let ([current-attr (first attrs)])
                 (let ([key (car current-attr)] [val (cdr current-attr)])
                   ;; Some attributes have a special
                   ;; serialization, like comments or boss
                   ;; or soldier tags. (Why, oh why did you
                   ;; have to introduce inconsistencies at
                   ;; every step?!)
                   (cond
                    [(equal? key "comment") (simple-format port "#~a" val)]
                    [(equal? key "boss") (simple-format port "<~a>" "boss")]
                    [(equal? key "soldier") (simple-format port "<~a>" "soldier")]
                    [else
                     (let ([attr-spacer (string-repeat separator attribute-spacing)]
                           [key-val-spacer (string-repeat separator name-value-spacing)])
                       (simple-format
                        port "~a:~a~a~a"
                        key key-val-spacer val attr-spacer))])))
               (iter-attrs (drop attrs 1))]))))
       (λ (c)
         (memq c '(#\newline #\tab #\return #\space)))))))
